{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit SelectQuestion;

interface

uses
  Classes, SysUtils, Pad, MiscUtils, TestCore, SecureRandom, Modifiers, TestUtils;

type
  TChoice = class;
  TChoiceList = TGenericObjectList<TChoice>;
  TSelectResponse = class;

  TChoiceFlag = (cfFixed, cfNegative);
  TChoiceFlags = set of TChoiceFlag;

  TSelectQuestion = class(TQuestionWithFormulation)
  private
    FSingleChoiceHint: Boolean;
    FChoices: TChoiceList;
    function GetChoiceCount: Integer;
    procedure CheckChoiceIndex(Index: Integer);
    function GetChoices(Index: Integer): TChoice;
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetResponseClass: TResponseClass; override;
    class procedure Spawn(var Question: TQuestion; Alterants: TAlterantList); override;
    class function Kind: TKind; override;
    class function DefaultNegativeChoiceText: String;
    function IsResponseCompatible(Candidate: TResponse): Boolean; override;
    function Evaluate(Candidate: TResponse): Single; override;
    procedure Filter; override;
    function CountFlaggedChoices(const FlagMask, FlagState: TChoiceFlags): Integer;
    function GetFlaggedChoiceIndex(const FlagMask, FlagState: TChoiceFlags): Integer;
    function FlaggedChoicePresent(const FlagMask, FlagState: TChoiceFlags): Boolean;
    procedure ShuffleChoices(const Permutation: TIntegerArray);
    procedure AddNegativeChoice;
    procedure Assign(Source: TQuestion); override;
    function AddChoice: TChoice;
    function ReplaceString(const OldString, NewString: String): Integer; override;
    function Response: TSelectResponse;

    property ChoiceCount: Integer read GetChoiceCount;
    property Choices[Index: Integer]: TChoice read GetChoices;
    property SingleChoiceHint: Boolean read FSingleChoiceHint write FSingleChoiceHint;
  end;

  TChoice = class
  private
    FPad: TPad;
    FFlags: TChoiceFlags;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TChoice);

    property Flags: TChoiceFlags read FFlags write FFlags;
    property Pad: TPad read FPad;
  end;

  TSelectResponse = class(TResponse)
  private
    FSelected: TIntegerList; { indices of selected choices in ascending order }
    procedure SortSelected;
    function GetSelectedCount: Integer;
    procedure CheckIndex(Index: Integer);
    function GetSelected(Index: Integer): Integer;
    procedure SetSelectedList(ChoiceIndices: TIntegerList);
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Select(ChoiceIndex: Integer);
    procedure Deselect(ChoiceIndex: Integer);
    function IsSelected(ChoiceIndex: Integer): Boolean;
    function IsEqual(Other: TSelectResponse): Boolean;
    procedure DeselectAll;
    function ComputeDifference(Original: TSelectResponse): Single;
    procedure Assign(Source: TResponse); override;

    property Selected[Index: Integer]: Integer read GetSelected;
    property SelectedCount: Integer read GetSelectedCount;
  end;

  TShuffleChoicesModifier = class(TModifier)
  public
    class function GetTitle: String; override;
    class function IsApplicableTo(QuestionKind: TKind): Boolean; override;
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList); override;
  end;

  TShuffleChoicesAlterant = class(TAlterant)
  private
    FPermutation: TIntegerArray;
  public
    procedure Apply(var Question: TQuestion); override;
    procedure SetPermutation(const Permutation: TIntegerArray);
    function GetPermutation: TIntegerArray;
  end;

  TAddNegativeChoiceModifier = class(TModifier)
  public
    class function GetTitle: String; override;
    class function IsApplicableTo(QuestionKind: TKind): Boolean; override;
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList); override;
  end;

  TAddNegativeChoiceAlterant = class(TAlterant)
  public
    procedure Apply(var Question: TQuestion); override;
  end;

  TSuppressSingleChoiceHintModifier = class(TModifier)
  public
    class function GetTitle: String; override;
    class function IsApplicableTo(QuestionKind: TKind): Boolean; override;
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList); override;
  end;

  TSetSingleChoiceHintAlterant = class(TAlterant)
  private
    FSingleChoiceHint: Boolean;
  public
    procedure Apply(var Question: TQuestion); override;

    property SingleChoiceHint: Boolean read FSingleChoiceHint write FSingleChoiceHint;
  end;

  TSetNegativeChoiceContentModifier = class(TModifier)
  private
    FContent: TPad;
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetTitle: String; override;
    class function IsLegacy: Boolean; override;
    class function IsApplicableTo(QuestionKind: TKind): Boolean; override;
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList); override;
    procedure GetContent(Content: TPad);
    procedure SetContent(Content: TPad);
    procedure Assign(Source: TModifier); override;
  end;

  TSetChoiceContentAlterant = class(TAlterant)
  private
    FChoiceIndex: Integer;
    FContent: TPad;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Apply(var Question: TQuestion); override;
    procedure SetContent(Content: TPad);
    procedure SetChoiceIndex(ChoiceIndex: Integer);
  end;

implementation

resourcestring
  SNegativeChoice = 'None of the above are correct.';
  SSuppressSingleChoiceHint = 'Allow Multiple Selection for Questions with a Single Correct Answer';
  SAddNegativeChoice = 'Add the "No Correct Answers" Choice';
  SSetNegativeChoiceContent = 'Set the "No Correct Answers" Choice Text';
  SShuffleChoices = 'Shuffle Choices';

{ TSelectQuestion }

procedure TSelectQuestion.CheckChoiceIndex(Index: Integer);
begin
  Assert( Index >= 0 );
  Assert( Index < ChoiceCount );
end;

function TSelectQuestion.CountFlaggedChoices(const FlagMask,
  FlagState: TChoiceFlags): Integer;
var
  c: TChoice;
begin
  Result := 0;
  for c in FChoices do
    if c.Flags * FlagMask = FlagState then
      Inc(Result);
end;

constructor TSelectQuestion.Create;
begin
  inherited;
  FChoices := TChoiceList.Create;
end;

destructor TSelectQuestion.Destroy;
begin
  FreeAndNil(FChoices);
  inherited;
end;

function TSelectQuestion.IsResponseCompatible(
  Candidate: TResponse): Boolean;
var
  i, n: Integer;
  c: TSelectResponse;
begin
  Result := Candidate is TSelectResponse;
  if Result then
  begin
    c := TSelectResponse(Candidate);
    for i := 0 to c.SelectedCount-1 do
    begin
      n := c.Selected[i];
      if (n < 0) or (n >= ChoiceCount) then
      begin
        Result := FALSE;
        Break;
      end;
    end;
  end;
end;

function TSelectQuestion.Evaluate(Candidate: TResponse): Single;
var
  c: TSelectResponse;
begin
  CheckResponseCompatible(Candidate);
  c := TSelectResponse(Candidate);
  if LaxEvaluation then
    Result := c.ComputeDifference(Response)
  else
  begin
    if Response.IsEqual(c) then
      Result := 1
    else
      Result := 0;
  end;
end;

procedure TSelectQuestion.Filter;
var
  c: TChoice;
begin
  inherited;
  Response.Clear;
  for c in FChoices do
    c.Flags := [];
end;

function TSelectQuestion.GetFlaggedChoiceIndex(const FlagMask,
  FlagState: TChoiceFlags): Integer;
begin
  for Result := 0 to ChoiceCount-1 do
    if FChoices[Result].Flags * FlagMask = FlagState then
      Exit;
  Result := -1;
end;

function TSelectQuestion.GetChoiceCount: Integer;
begin
  Result := FChoices.Count;
end;

function TSelectQuestion.GetChoices(Index: Integer): TChoice;
begin
  CheckChoiceIndex(Index);
  Result := FChoices[Index];
end;

function TSelectQuestion.Response: TSelectResponse;
begin
  Result := TSelectResponse(inherited);
end;

class function TSelectQuestion.GetResponseClass: TResponseClass;
begin
  Result := TSelectResponse;
end;

procedure TSelectQuestion.Assign(Source: TQuestion);
var
  q: TSelectQuestion;
  c: TChoice;
begin
  inherited;
  q := Source as TSelectQuestion;
  FSingleChoiceHint := q.FSingleChoiceHint;

  FChoices.Clear;
  for c in q.FChoices do
    AddChoice.Assign(c);
end;

function TSelectQuestion.AddChoice: TChoice;
begin
  Result := FChoices.AddSafely(TChoice.Create);
end;

function TSelectQuestion.FlaggedChoicePresent(const FlagMask,
  FlagState: TChoiceFlags): Boolean;
begin
  Result := GetFlaggedChoiceIndex(FlagMask, FlagState) <> -1;
end;

procedure TSelectQuestion.ShuffleChoices(const Permutation: TIntegerArray);
{ Permutation includes movable choices only. }
var
  MovableChoices: TIntegerArray;
  CompletePermutation: TIntegerArray; { including fixed choices }
  i, Index, MovableChoiceCount: Integer;
  NewSelected: TIntegerList;
begin
  MovableChoiceCount := CountFlaggedChoices([cfFixed], []);
  Assert( Length(Permutation) = MovableChoiceCount );

  if MovableChoiceCount >= 2 then
  begin
    SetLength(MovableChoices, MovableChoiceCount);
    Index := 0;
    for i := 0 to ChoiceCount-1 do
      if not (cfFixed in FChoices[i].Flags) then
      begin
        MovableChoices[Index] := i;
        Inc(Index);
        if Index = MovableChoiceCount then
          Break;
      end;

    SetLength(CompletePermutation, ChoiceCount);
    Index := 0;
    for i := 0 to ChoiceCount-1 do
    begin
      if cfFixed in FChoices[i].Flags then
        CompletePermutation[i] := i
      else
      begin
        CompletePermutation[i] := MovableChoices[Permutation[Index]];
        Inc(Index);
      end;
    end;

    PermuteList(FChoices, CompletePermutation);

    NewSelected := TIntegerList.Create;
    try
      for i := 0 to ChoiceCount-1 do
        if Response.IsSelected(CompletePermutation[i]) then
          NewSelected.Add(i);
      Response.SetSelectedList(NewSelected);
    finally
      NewSelected.Free;
    end;
  end;
end;

procedure TSelectQuestion.AddNegativeChoice;
var
  Choice: TChoice;
begin
  Choice := AddChoice;
  Choice.Flags := Choice.Flags + [cfFixed, cfNegative];
  Choice.Pad.AddText(UTF8Decode(SNegativeChoice));
end;

class procedure TSelectQuestion.Spawn(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TSetSingleChoiceHintAlterant;
begin
  inherited;
  Assert( Question is TSelectQuestion );

  if (TSelectQuestion(Question).Response.SelectedCount = 1) and not TSelectQuestion(Question).SingleChoiceHint then
  begin
    Alterant := TSetSingleChoiceHintAlterant.Create;
    Alterants.Add(Alterant);

    Alterant.SingleChoiceHint := TRUE;
    Alterant.Apply(Question);
  end;
end;

class function TSelectQuestion.Kind: TKind;
begin
  Result := $b773e5dd7ef709d1;
end;

class function TSelectQuestion.DefaultNegativeChoiceText: String;
begin
  Result := SNegativeChoice;
end;

function TSelectQuestion.ReplaceString(const OldString,
  NewString: String): Integer;
var
  c: TChoice;
begin
  Result := inherited;
  for c in FChoices do
    Inc(Result, c.FPad.ReplaceString(OldString, NewString));
end;

{ TChoice }

constructor TChoice.Create;
begin
  inherited;
  FPad := TPad.Create;
end;

destructor TChoice.Destroy;
begin
  FreeAndNil(FPad);
  inherited;
end;

procedure TChoice.Assign(Source: TChoice);
begin
  FPad.Assign(Source.FPad);
  FFlags := Source.FFlags;
end;

{ TSelectResponse }

procedure TSelectResponse.Select(ChoiceIndex: Integer);
begin
  if not IsSelected(ChoiceIndex) then
  begin
    FSelected.Add(ChoiceIndex);
    SortSelected;
    Changed;
  end;
end;

procedure TSelectResponse.SetSelectedList(ChoiceIndices: TIntegerList);
begin
  FSelected.Assign(ChoiceIndices);
  Changed;
end;

function TSelectResponse.IsSelected(ChoiceIndex: Integer): Boolean;
begin
  Result := FSelected.IndexOf(ChoiceIndex) <> -1;
end;

procedure TSelectResponse.CheckIndex(Index: Integer);
begin
  Assert( Index >= 0 );
  Assert( Index < SelectedCount );
end;

constructor TSelectResponse.Create;
begin
  inherited;
  FSelected := TIntegerList.Create;
end;

destructor TSelectResponse.Destroy;
begin
  FreeAndNil(FSelected);
  inherited;
end;

function TSelectResponse.IsEqual(Other: TSelectResponse): Boolean;
var
  i: Integer;
begin
  Result := SelectedCount = Other.SelectedCount;
  if Result then
    for i := 0 to SelectedCount-1 do
      if FSelected[i] <> Other.FSelected[i] then
      begin
        Result := FALSE;
        Break;
      end;
end;

function TSelectResponse.GetSelectedCount: Integer;
begin
  Result := FSelected.Count;
end;

function TSelectResponse.GetSelected(Index: Integer): Integer;
begin
  CheckIndex(Index);
  Result := FSelected[Index];
end;

procedure TSelectResponse.DeselectAll;
begin
  FSelected.Clear;
  Changed;
end;

procedure TSelectResponse.Deselect(ChoiceIndex: Integer);
var
  i: Integer;
begin
  i := FSelected.IndexOf(ChoiceIndex);
  if i <> -1 then
  begin
    FSelected.Delete(i);
    Changed;
  end;
end;

function TSelectResponse.ComputeDifference(
  Original: TSelectResponse): Single;
var
  n, m, s, Res: Integer;
begin
  if SelectedCount <= Original.SelectedCount then
  begin
    s := 0;
    n := 0;
    m := 0;
    while (n < Original.SelectedCount) and (m < SelectedCount) do
    begin
      Res := CompareIntegers(Original.FSelected[n], FSelected[m]);
      if Res = 0 then
      begin
        Inc(s);
        Inc(n);
        Inc(m);
      end
      else if Res > 0 then { Self contains a choice absent from Original }
      begin
        s := -1;
        Break;
      end
      else { Original contains a choice absent from Self }
        Inc(n);
    end;
    if (n = Original.SelectedCount) and (m < SelectedCount) then
      s := -1;
  end
  else
    s := -1;

  { Now s is the number of choices shared by Self and Original,
    or -1 if Self contains at least one choice absent from Original. }
  if s = -1 then
    Result := 0
  else if s = Original.SelectedCount then
    Result := 1
  else
    Result := s / Original.SelectedCount;
end;

procedure TSelectResponse.Assign(Source: TResponse);
begin
  inherited;
  SetSelectedList((Source as TSelectResponse).FSelected);
end;

procedure TSelectResponse.SortSelected;
begin
  FSelected.Sort(CompareIntegers);
end;

{ TShuffleChoicesModifier }

procedure TShuffleChoicesModifier.Apply(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TShuffleChoicesAlterant;
  SelectQuestion: TSelectQuestion;
  MovableChoiceCount: Integer;
begin
  if Question is TSelectQuestion then
  begin
    SelectQuestion := TSelectQuestion(Question);
    MovableChoiceCount := SelectQuestion.CountFlaggedChoices([cfFixed], []);
    if MovableChoiceCount >= 2 then
    begin
      Alterant := TShuffleChoicesAlterant.Create;
      Alterants.Add(Alterant);

      Alterant.SetPermutation(GenerateRandomPermutation(MovableChoiceCount, SecureRandomInteger));
      Alterant.Apply(Question);
    end;
  end;
end;

class function TShuffleChoicesModifier.GetTitle: String;
begin
  Result := SShuffleChoices;
end;

class function TShuffleChoicesModifier.IsApplicableTo(QuestionKind: TKind): Boolean;
begin
  Result := QuestionKind = TSelectQuestion.Kind;
end;

{ TShuffleChoicesAlterant }

procedure TShuffleChoicesAlterant.Apply(var Question: TQuestion);
var
  SelectQuestion: TSelectQuestion;
begin
  Assert( Question is TSelectQuestion );
  SelectQuestion := TSelectQuestion(Question);
  SelectQuestion.ShuffleChoices(FPermutation);
end;

function TShuffleChoicesAlterant.GetPermutation: TIntegerArray;
begin
  Result := Copy(FPermutation);
end;

procedure TShuffleChoicesAlterant.SetPermutation(const Permutation: TIntegerArray);
begin
  FPermutation := Copy(Permutation);
end;

{ TAddNegativeChoiceModifier }

procedure TAddNegativeChoiceModifier.Apply(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TAddNegativeChoiceAlterant;
begin
  if (Question is TSelectQuestion) and not TSelectQuestion(Question).FlaggedChoicePresent(
    [cfNegative], [cfNegative]) then
  begin
    Alterant := TAddNegativeChoiceAlterant.Create;
    Alterants.Add(Alterant);
    Alterant.Apply(Question);
  end;
end;

class function TAddNegativeChoiceModifier.GetTitle: String;
begin
  Result := SAddNegativeChoice;
end;

class function TAddNegativeChoiceModifier.IsApplicableTo(QuestionKind: TKind): Boolean;
begin
  Result := QuestionKind = TSelectQuestion.Kind;
end;

{ TAddNegativeChoiceAlterant }

procedure TAddNegativeChoiceAlterant.Apply(var Question: TQuestion);
var
  SelectQuestion: TSelectQuestion;
begin
  Assert( Question is TSelectQuestion );
  SelectQuestion := TSelectQuestion(Question);
  SelectQuestion.AddNegativeChoice;
end;

{ TSuppressSingleChoiceHintModifier }

procedure TSuppressSingleChoiceHintModifier.Apply(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TSetSingleChoiceHintAlterant;
begin
  if (Question is TSelectQuestion) and TSelectQuestion(Question).SingleChoiceHint then
  begin
    Alterant := TSetSingleChoiceHintAlterant.Create;
    Alterants.Add(Alterant);

    Alterant.SingleChoiceHint := FALSE;
    Alterant.Apply(Question);
  end;
end;

class function TSuppressSingleChoiceHintModifier.GetTitle: String;
begin
  Result := SSuppressSingleChoiceHint;
end;

class function TSuppressSingleChoiceHintModifier.IsApplicableTo(QuestionKind: TKind): Boolean;
begin
  Result := QuestionKind = TSelectQuestion.Kind;
end;

{ TSetSingleChoiceHintAlterant }

procedure TSetSingleChoiceHintAlterant.Apply(var Question: TQuestion);
begin
  Assert( Question is TSelectQuestion );
  TSelectQuestion(Question).SingleChoiceHint := FSingleChoiceHint;
end;

{ TSetNegativeChoiceContentModifier }

procedure TSetNegativeChoiceContentModifier.Apply(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TSetChoiceContentAlterant;
  Index: Integer;
  SelectQuestion: TSelectQuestion;
begin
  if Question is TSelectQuestion then
  begin
    SelectQuestion := TSelectQuestion(Question);
    Index := SelectQuestion.GetFlaggedChoiceIndex([cfNegative], [cfNegative]);
    if Index <> -1 then
    begin
      Alterant := TSetChoiceContentAlterant.Create;
      Alterants.Add(Alterant);

      Alterant.SetChoiceIndex(Index);
      Alterant.SetContent(FContent);

      Alterant.Apply(Question);
    end;
  end;
end;

constructor TSetNegativeChoiceContentModifier.Create;
begin
  inherited;
  FContent := TPad.Create;
  FContent.AddText(UTF8Decode(SNegativeChoice));
end;

destructor TSetNegativeChoiceContentModifier.Destroy;
begin
  FreeAndNil(FContent);
  inherited;
end;

class function TSetNegativeChoiceContentModifier.GetTitle: String;
begin
  Result := SSetNegativeChoiceContent;
end;

class function TSetNegativeChoiceContentModifier.IsLegacy: Boolean;
begin
  Result := TRUE;
end;

class function TSetNegativeChoiceContentModifier.IsApplicableTo(
  QuestionKind: TKind): Boolean;
begin
  Result := QuestionKind = TSelectQuestion.Kind;
end;

procedure TSetNegativeChoiceContentModifier.GetContent(Content: TPad);
begin
  Content.Assign(FContent);
end;

procedure TSetNegativeChoiceContentModifier.SetContent(Content: TPad);
begin
  FContent.Assign(Content);
end;

procedure TSetNegativeChoiceContentModifier.Assign(Source: TModifier);
begin
  inherited;
  FContent.Assign((Source as TSetNegativeChoiceContentModifier).FContent);
end;

{ TSetChoiceContentAlterant }

procedure TSetChoiceContentAlterant.Apply(var Question: TQuestion);
var
  SelectQuestion: TSelectQuestion;
begin
  Assert( Question is TSelectQuestion );
  SelectQuestion := TSelectQuestion(Question);
  Assert( FChoiceIndex >= 0 );
  Assert( FChoiceIndex < SelectQuestion.ChoiceCount );

  SelectQuestion.Choices[FChoiceIndex].Pad.Assign(FContent);
end;

constructor TSetChoiceContentAlterant.Create;
begin
  inherited;
  FContent := TPad.Create;
  FChoiceIndex := -1;
end;

destructor TSetChoiceContentAlterant.Destroy;
begin
  FreeAndNil(FContent);
  inherited;
end;

procedure TSetChoiceContentAlterant.SetContent(Content: TPad);
begin
  FContent.Assign(Content);
end;

procedure TSetChoiceContentAlterant.SetChoiceIndex(ChoiceIndex: Integer);
begin
  FChoiceIndex := ChoiceIndex;
end;

initialization

  ModifierRegistry.Add(TSuppressSingleChoiceHintModifier);
  ModifierRegistry.Add(TAddNegativeChoiceModifier);
  ModifierRegistry.Add(TSetNegativeChoiceContentModifier);
  ModifierRegistry.Add(TShuffleChoicesModifier);

end.

